home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PBLIB1 / PROGS / BFILEGEN.PAS next >
Pascal/Delphi Source File  |  1994-05-03  |  9KB  |  329 lines
  1. Program BFILEGen;
  2.  
  3. {$M 10000,0,10000}
  4.  
  5. uses PbMISC, PbDATA, PbOBJS, PbPARMS;
  6.  
  7. {
  8. Description:  Program to generate PASCAL Type for BFILE record
  9.  
  10. Author      : Howard Richoux
  11. Date        : 10/10/90
  12. Last revised: 1/19/94 hnr 1.00 started from dbpasgen
  13.               2/18/94 hnr 1.02 new libraries
  14. Application : IBM PC and compatibles, done in Turbo Pascal 5.0
  15. Status      : Placed in the Public Domain by HNR Software 1/29/94
  16. Published in: none
  17. }
  18.  
  19.  
  20.  
  21. var bfilename : string[40];
  22. var recname : string[7];
  23.  
  24. var L       : OUT_object_0;
  25.  
  26. var DDL       : HOLD_object;
  27.     FieldSpec : string;       { FIELDS=[fld1(c10),fld2(i)...] }
  28.  
  29.  
  30. Function  DDLRecSize(var Fl : hold_object) : longint;
  31. var i,j : integer;
  32.      begin
  33.      j := 0;
  34.      for i := 1 to DDL.count do j := j + DDL.fetchNumN(i);
  35.      DDLRecSize := j;
  36.      end;
  37.  
  38.  
  39. Procedure DDLPasFields(var Fl : hold_object);
  40. var i,j,len : integer;
  41.     s, nam,typstr  : string;
  42.     typ     : char;
  43.      begin
  44.      for j := 1 to DDL.count do
  45.           begin
  46.           nam  := UpCaseStr(Fl.fetchStrN(j));
  47.           s    := GetDelimitedStr(nam,'(',')');
  48.           typ  := s[1];
  49.           typstr := '';
  50.           case typ of
  51.              'I' : typstr := 'integer;';  {integer}
  52.              'L' : typstr := 'longint;';  {longint}
  53.              'R' : typstr := 'real;';     {real}
  54.              'C' : begin                  {char array}
  55.                    len := GetInteger(s);
  56.                    if len = 0 then len := 1;
  57.                    if len > 1 then
  58.                         typstr := 'array[1..'+integerstr(len,3)+'] of char;'
  59.                    else typstr := 'char;';
  60.                    end;
  61.               else begin      {unknown}
  62.                    typstr := '{Unknown field type ['+typ+']}';
  63.                    len := 0;
  64.                    end;
  65.               end;
  66.           L.out('          '+leftstr(nam,10)+': '+typstr);
  67.           end;
  68.      end;
  69.  
  70.  
  71. Procedure LoadDDL(var recroot : string);
  72. var i,j : integer;
  73.     s, s1,s2,s3 : string;
  74.      begin
  75.      writeln('-------');
  76.      writeln('{FIELDS='+FieldSpec+'}');
  77.      DDL.init(50);
  78.      s := RemoveBrackets(FieldSpec);
  79.      writeln('{FIELDS='+s+'}');
  80.      while length(s) > 0 do
  81.           begin
  82.           s1 := GetLeftStr(s,',');
  83.           s3 := s1;                              {keep it}
  84.           s2 := UpCaseStr(GetDelimitedStr(s1,'(',')'));
  85.           case s2[1] of
  86.              'I' : i := 2;  {integer}
  87.              'L' : i := 4;  {longint}
  88.              'R' : i := 4;  {real}
  89.              'C' : begin    {char array}
  90.                    i  := GetInteger(s2);                  {keep this}
  91.                    if i = 0 then i := 1;
  92.                    end;
  93.               else begin
  94.                    writeln('Unknown field type [',s2[1],']');
  95.                    i := 0;
  96.                    end;
  97.               end;
  98.           DDL.append(s3,i);
  99.           end;
  100.      writeln('-------');
  101.      DDL.dump;
  102.      writeln('  Total length ',DDLRecSize(DDL));
  103.      writeln('-------');
  104.      end;
  105.  
  106.  
  107. Procedure MakeUnit(RecRoot : string);
  108. var i, width   : integer;
  109.     rtype      : char;
  110.     tmp, tpe   : string[40];
  111.      begin
  112.      L.out('{SECTION ..B'+RecRoot+' }');
  113.      L.out(' ');
  114.      L.out('{ '+pProgID+' - hnr   '+FormatDTime+
  115.               ', Placed in the Public Domain by HNR Software 1/94 }');
  116.      L.out(' ');
  117.      L.out('Unit b'+RecRoot+';');
  118.      L.out(' ');
  119.      L.out('INTERFACE');
  120.      L.out(' ');
  121.      L.out('Uses PbMISC, PbOBJS;');
  122.      L.out(' ');
  123.      end;
  124.  
  125.  
  126. Procedure MakeUnitEnd;
  127.      begin
  128.      L.out(' ');
  129.      L.out('{SECTION zzInitialization }');
  130.      L.out('      begin { initialization }');
  131.      L.out('      end.');
  132.      end;
  133.  
  134.  
  135. Procedure MakeObject(RecRoot : string);
  136. var i, width   : integer;
  137.     rtype      : char;
  138.     tmp, tpe   : string[40];
  139.      begin
  140.      L.out('{SECTION .'+RecRoot+'_BFILE_object }');
  141.      L.out(' ');
  142.      L.out('const '+RecRoot+'_recsize = '+
  143.                 integerstr(DDLRecSize(DDL),4)+';');
  144.      L.out(' ');
  145.      L.out('const '+RecRoot+'_filename = '''+bfilename+''';');
  146.      L.out(' ');
  147.      L.out('type  '+RecRoot+'_BFILE_object = OBJECT(BFILE_object)');
  148.      L.out('         rec       : '+RecRoot+'_record;');
  149.      L.out('         Procedure  init     ( fn : string; fmode : integer);');
  150.      L.out('         Function   ReadRec  ( i  : longint) : boolean;');
  151.      L.out('         Function   WriteRec ( i  : longint) : boolean;');
  152.      L.out('         Function   ReadNextRec              : boolean;');
  153.      L.out('         Function   AppendRec                : boolean;');
  154.      L.out('         end;');
  155.      L.out(' ');
  156.      L.out('{SECTION .zImplementation }');
  157.      L.out('IMPLEMENTATION');
  158.      L.out(' ');
  159.      end;
  160.  
  161.  
  162. Procedure MakeInitProc(RecRoot : string);
  163. var i, width   : integer;
  164.     rtype      : char;
  165.     tmp,tmp2,tpe    : string[20];
  166.      begin
  167.      L.out(' ');
  168.      L.out('Procedure  '+RecRoot+'_BFILE_object.Init(fn : string; fmode : integer);');
  169.      L.out('     begin');
  170.      L.out('     BFILE_object.init(fn,'+RecRoot+'_recsize,fmode);');
  171.      L.out('     end;');
  172.      L.out(' ');
  173.      L.out(' ');
  174.      end;
  175.  
  176.  
  177. Procedure MakeRecType(RecRoot : string);
  178. var i, width   : integer;
  179.     rtype      : char;
  180.     tmp, tpe   : string;
  181.      begin
  182.      L.out('{SECTION .'+RecRoot+'_record }');
  183.      L.out('type '+RecRoot+'_record = record ');
  184.      DDLPasFields(DDL);
  185.      L.OUT('          end;');
  186.      L.out(' ');
  187.      end;
  188.  
  189.  
  190.  
  191. Procedure MakeReadWriteProcs(RecRoot : string);
  192. var i, width   : integer;
  193.     rtype      : char;
  194.     tmp,tmp2,tpe    : string[20];
  195.      begin
  196.      L.out(' ');
  197.      L.out('Function  '+RecRoot+'_BFILE_object.ReadRec( i : longint) : boolean;');
  198.      L.OUT('     begin');
  199.      L.OUT('     ReadRec := true;');
  200.      L.OUT('     if not BFILE_object.fetchN(i,rec) then ');
  201.      L.OUT('          begin');
  202.      L.OUT('          ReadRec := false;');
  203.      L.OUT('          fillchar(rec,sizeof(rec),0);');
  204.      L.OUT('          end;');
  205.      L.OUT('     end;');
  206.      L.out(' ');
  207.      L.out(' ');
  208.      L.out('Function  '+RecRoot+'_BFILE_object.WriteRec( i : longint) : boolean;');
  209.      L.out('     begin');
  210.      L.out('     WriteRec := true;');
  211.      L.OUT('     if not BFILE_object.storeN(i,rec) then ');
  212.      L.OUT('          begin');
  213.      L.OUT('          WriteRec := false;');
  214.      L.OUT('          end;');
  215.      L.out('     end;');
  216.      L.out(' ');
  217.      L.out(' ');
  218.      L.out('Function  '+RecRoot+'_BFILE_object.ReadNextRec : boolean;');
  219.      L.OUT('var n : longint;');
  220.      L.OUT('     begin');
  221.      L.OUT('     ReadNextRec := true;');
  222.      L.OUT('     n := curr+1;');
  223.      L.OUT('     if not BFILE_object.fetchN(n,rec) then ');
  224.      L.OUT('          begin');
  225.      L.OUT('          ReadNextRec := false;');
  226.      L.OUT('          fillchar(rec,sizeof(rec),0);');
  227.      L.OUT('          end;');
  228.      L.OUT('     end;');
  229.      L.out(' ');
  230.      L.out(' ');
  231.      L.out('Function  '+RecRoot+'_BFILE_object.AppendRec : boolean;');
  232.      L.OUT('var n : longint;');
  233.      L.OUT('     begin');
  234.      L.out('     AppendRec := true;');
  235.      L.OUT('     n := curr+1;');
  236.      L.OUT('     if not BFILE_object.storeN(n,rec) then ');
  237.      L.OUT('          begin');
  238.      L.OUT('          AppendRec := false;');
  239.      L.OUT('          end;');
  240.      L.out('     end;');
  241.      L.out(' ');
  242.      L.out(' ');
  243.      L.out(' ');
  244.      end;
  245.  
  246.  
  247.  
  248. Function MakeRoot(path : string) : string;
  249. var s : string;
  250.     i : integer;
  251.      begin
  252.      s := path;
  253.      i := pos('\',s);
  254.      while i > 0 do
  255.           begin
  256.           delete(s,1,i);
  257.           i := pos('\',s);
  258.           end;
  259.      i := pos('.',s);
  260.      if i > 1 then s := leftstr(s,i-1);
  261.      Makeroot := s;
  262.      end;
  263.  
  264.  
  265. Procedure MakePas(RecRoot : string);
  266. var outfname : string[40];
  267.      begin
  268.      getdir(0,outfname);
  269.      outfname := addbackslash(outfname) + 'b' + RecRoot;
  270.      forceext(outfname,'pas');
  271.      writeln('writing to ',outfname);
  272.      L.LISTinit(outfname,OUT_typREWRITE);
  273.      L.LISTopen;
  274.  
  275.      MakeUnit(RecRoot);
  276.      MakeRecType(RecRoot);
  277.      MakeObject(RecRoot);
  278.      MakeInitProc(RecRoot);
  279.      MakeReadWriteProcs(RecRoot);
  280.      MakeUnitEnd;
  281.  
  282.      L.done;
  283.      end;
  284.  
  285.  
  286. Procedure DoBFILEGen(bfilename : string);
  287. var fn : string[40];
  288.     i  : integer;
  289.     RecRoot : string[8];
  290.      begin
  291.      fn := bfilename;
  292.      ForceExt(fn,'dbf');
  293.      writeln('fn ',fn);
  294.      if recname = '' then RecRoot := UpCaseStr(MakeRoot(fn))
  295.      else RecRoot := UpCaseStr(recname);
  296.      writeln('record name= ',RecRoot);
  297.      LoadDDL(RecRoot);
  298.      MakePas(RecRoot);
  299.      end;
  300.  
  301.  
  302. Procedure BFILEGenInit;
  303.      begin
  304.      recname := '';
  305.      bfilename := '';
  306.  
  307.      addparm(1,'REC','');
  308.      addparm(1,'FILE','');
  309.      addparm(1,'FIELDS','');
  310.      StandardpVarsInit;
  311.      bfilename := GetParmStr('FILE');
  312.      FieldSpec := GetParmSTr('FIELDS');
  313.      recname   := GetParmSTr('REC');
  314.  
  315.      if paramcount > 0 then bfilename := paramstr(1);
  316.      end;
  317.  
  318.  
  319.      begin
  320.      pProgID := 'BFILEGen 1.02';
  321.      BFILEGenInit;
  322.      if FieldSpec <> '' then
  323.           begin
  324.           DoBFILEGen(bfilename);
  325.           end
  326.      else writeln('Without specifying a FIELDS= list, there is no point in this exercise');
  327.      writeln('');
  328.      end.
  329.